home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
User's Choice Windows CD
/
User's Choice Windows CD (CMS Software)(1993).iso
/
windows4
/
plx17.zip
/
PRINTER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-06-14
|
11KB
|
435 lines
unit Printer; {Unit by Doug Overmyer 11/91 update 6/1/92}
{******************** Interface ************************}
Interface
uses WinTypes, WinProcs,WObjects,Strings,Win31,CommDlg;
const
id_ChgPrnDlgOK = 2599;
id_ChgPrnDlgLB1 = 2598;
type
PAbortDlg = ^TAbortDlg;
TAbortDlg = object(TDialog)
procedure Cancel(var Msg:TMessage);virtual id_First+id_Cancel;
end;
type
PChgPrnDlg = ^TChgPrnDlg; {used by ChangePrinter()}
TChgPrnDlg = object(TDialog)
AllDevicesBuf:Array[0..4096] of Char;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDChgPrtDlgOK(var Msg:TMessage);virtual id_First+id_ChgPrnDlgOK;
end;
type
PPrinter = ^TPrinter;
TPrinter = object(TObject)
PrintDC,PrintIC:HDC;
CurFont:HFont;
LineX,LineY:Integer; {line width and height for CurFont}
PageNumber:Integer; {current page number}
Metrics:TTextMetric; {current text metrics}
EscResult:Integer; {result of most recent ESC call}
CurX,CurY:Integer; {print Cursor X,Y position in device units}
PageX,PageY:Integer;{page width and height in device units}
LogPixX,LogPixY:Integer; {pixels/inch}
Printing:Boolean;
constructor Init;
destructor Done;virtual;
function GetPrintDC:Boolean;virtual;
procedure GetPrnParms;virtual;
procedure InstallAbortProc;virtual;
procedure SetupPage;virtual;
function PrnStart(DocName:PChar):Boolean;virtual;
procedure NewPage;virtual;
procedure PrnStop;virtual;
function GetIC:HDC;virtual;
function DeleteIC:Boolean;virtual;
function SetFont(NewFont:HFont):HFont;virtual;
procedure PrnDeviceMode(ParentWindow:PWindowsObject);virtual;
procedure ChangePrinter(ParentWindow:PwindowsObject);virtual;
end;
PLPrinter = ^TLPrinter;
TLPrinter = object(TPrinter)
Margin:TRect; {margin in device units}
FooterY:Integer; {height of footer in device units}
IsFooter:Boolean; {True = is printing footer}
constructor Init;
procedure PrintLine(aString:PChar);virtual;
procedure PrnStop;virtual;
procedure CheckNewPage;virtual;
procedure DoHeader;virtual;
procedure DoFooter;virtual;
procedure SetupPage;virtual;
procedure SetTOP;virtual;
procedure SetMarginL(NewMargin:Integer);virtual;
procedure SetMarginR(NewMargin:Integer);virtual;
procedure SetMarginT(NewMargin:Integer);virtual;
procedure SetMarginB(NewMargin:Integer);virtual;
end;
{to use a TLPrinter object, call
0. Subclass DoHeader,DoFooter properly
1. New.....Init
2. PrtStart
3. SetMarginL, SetFont, etc. Also set FooterY as needed.
4. SetupPage (does the DoHeader if any)
5. printLine (as needed)
6. DoFooter, PrnStop (do one last footer before stopping)
7. SetFont (if needed to restore 'old font')
8. Dispose
alternative - to get a PrintDC only
1. New...Init
2. GetIC
3. use the IC, TextMetrics, other info, but NO drawing/printing
4. DeleteIC
5. Dispose
}
{********************** Implementation *********************}
Implementation
{$R printer.res}
{********************* Globals & Functions *********************}
var
Aborted:Boolean;
AbortDlg:PAbortDlg;
PAbortProc:TFarProc;
function AbortProc(PrtDC:HDC;Code:Integer):Boolean;export;
var
Msg:TMsg;
begin
while (not Aborted) and (AbortDlg^.HWindow <> 0) and
PeekMessage(Msg,0,0,0,pm_Remove) do
if not IsDialogMessage(AbortDlg^.HWindow,Msg) then
begin
translateMessage(Msg);
DispatchMessage(Msg);
end;
AbortProc := not Aborted;
end;
{***************************************************************}
constructor TPrinter.Init;
begin
TObject.Init;
PrintDC := 0;PrintIC := 0;
CurX := 0;
CurY := 0;
Aborted := False;
CurFont := GetStockObject(Device_Default_Font);
PageNumber := 1;
end;
destructor TPrinter.Done;
begin
TObject.Done;
end;
function TPrinter.PrnStart(DocName:PChar):Boolean;
var
DI:TDocInfo;
begin
GetPrintDC;
With DI do
begin
cbSize := sizeOf(TDocInfo);
lpSzDocName := DocName;
lpSzOutput := nil;
end;
If PrintDC <> 0 then
begin
GetPrnParms;
InstallAbortProc;
if EscResult > 0 then
begin
EscResult := StartDoc(PrintDC,DI);
Printing := (EscResult > 0);
StartPage(PrintDC);
end;
end
else
Printing := false;
If not Printing then
begin
if AbortDlg <> nil then
AbortDlg^.CloseWindow;
MessageBox(Application^.MainWindow^.HWindow,'Printer Initialization Failed',
'Error',mb_IconExclamation or mb_OK);
end;
PrnStart := Printing;
end;
function TPrinter.GetPrintDC;
var
PD:TPrintDlg;
begin
with PD do
begin
lStructSize := sizeof(TPrintDlg);
hWndOwner := 0;
hDevMode := THandle(nil);
hDevNames := THandle(nil);
hDC := 0;
Flags := PD_RETURNDC OR PD_RETURNDEFAULT;
hInstance := THandle(nil);
nCopies := 1;
end;
PrintDlg(PD);
PrintDC := PD.hDc;
If PD.hDevMode > 0 then GlobalFree(PD.hDevMode);
if PD.hDevNames > 0 then GlobalFree(PD.hDevNames);
GetPrintDC := (PrintDC > 0);
end;
procedure TPrinter.GetPrnParms;
begin
GetTextMetrics(PrintDC,Metrics);
LogPixX := GetDeviceCaps(PrintDC,LogPixelsX);
LogPixY := GetDeviceCaps(PrintDC,LogPixelsY);
PageX := GetDeviceCaps(PrintDC,HorzRes);
PageY := GetDeviceCaps(PrintDC,VertRes);
LineY := Metrics.tmHeight + Metrics.tmExternalLeading;
end;
procedure TPrinter.InstallAbortProc;
begin
AbortDlg := new(PAbortDlg,Init(Application^.MainWindow,
'AbortDlg'));
AbortDlg^.EnableAutoCreate;
Application^.MakeWindow(AbortDlg);
PAbortProc := MakeProcInstance(@AbortProc,HInstance);
EscResult := SetAbortProc(PrintDC,TAbortProc(PAbortProc));
end;
procedure TPrinter.SetupPage;
begin
{Formal method}
end;
procedure TPrinter.NewPage;
begin
if Printing and (EscResult > 0) then
EscResult := EndPage(PrintDC);
StartPage(PrintDC);
SelectObject(PrintDC,CurFont);
Inc(PageNumber);
end;
procedure TPrinter.PrnStop;
begin
if Printing then
begin
if AbortDlg <> nil then
AbortDlg^.CloseWindow;
if EscResult > 0 then
EndDoc(PrintDC);
DeleteDC(PrintDC);
Printing := false;
end;
end;
function TPrinter.GetIC:HDC;
var
PD:TPrintDlg;
begin
with PD do
begin
lStructSize := sizeof(TPrintDlg);
hWndOwner := 0;
hDevMode := THandle(nil);
hDevNames := THandle(nil);
hDC := 0;
Flags := PD_RETURNIC OR PD_RETURNDEFAULT;
hInstance := THandle(nil);
nCopies := 1;
end;
PrintDlg(PD);
PrintIC := PD.hDc;
GetTextMetrics(PrintIC,Metrics);
LogPixX := GetDeviceCaps(PrintIC,LogPixelsX);
LogPixY := GetDeviceCaps(PrintIC,LogPixelsY);
PageX := GetDeviceCaps(PrintIC,HorzRes);
PageY := GetDeviceCaps(PrintIC,VertRes);
LineY := Metrics.tmHeight + Metrics.tmExternalLeading;
If PD.hDevMode > 0 then GlobalFree(PD.hDevMode);
if PD.hDevNames > 0 then GlobalFree(PD.hDevNames);
GetIC:= PrintIC;
end;
function TPrinter.DeleteIC;
begin
DeleteIC := (PrintIC > 0);
if PrintDC > 0 then
DeleteDC(PrintIC);
PrintIC := 0;
end;
function TPrinter.SetFont(NewFont:HFont):HFont;
begin
SetFont :=SelectObject(PrintDC,NewFont);
CurFont := NewFont;
GetPrnParms;
end;
procedure TPrinter.PrnDeviceMode(ParentWindow:PWindowsObject);
var
PD:TPrintDlg;
begin
with PD do
begin
lStructSize := sizeof(TPrintDlg);
hWndOwner := ParentWindow^.HWindow;
hDevMode := THandle(nil);
hDevNames := THandle(nil);
Flags := PD_PRINTSETUP;
hInstance := THandle(nil);
nCopies := 1;
end;
PrintDlg(PD);
end;
procedure TPrinter.ChangePrinter(ParentWindow:PWindowsObject);
var
ChgPrnDlg:PChgPrnDlg;
begin
ChgPrnDlg := New(PChgPrnDlg,Init(Parentwindow,'ChgPrnDlg'));
Application^.ExecDialog(ChgPrnDlg);
end;
{********************* TAbortDlg **********************}
procedure TAbortDlg.Cancel(var Msg:TMessage);
begin
Aborted := True;
TDialog.Cancel(Msg);
end;
{******************** TChgPrnDlg ************************}
procedure TChgPrnDlg.WMInitDialog(var Msg:TMessage);
var
pAllDevicesBuf:PChar;
Buf:Array[0..64] of Char;
pBuf:PChar;
Printer1:Array[0..64] of Char;
Printer:Array[0..64] of Char;
pPrinter:PChar;
begin
GetProfileString('devices',nil,'',AllDevicesBuf,sizeof(AllDevicesBuf));
TDialog.WMInitDialog(Msg);
pAllDevicesBuf := AllDevicesBuf;
pBuf := @Buf;
pPrinter := @Printer;
repeat
StrCopy(Buf,pAllDevicesBuf);
GetProfileString('devices',Buf,'',Printer1,sizeof(Printer1));
StrCat(StrCat(StrCopy(Printer,Buf),','),Printer1);
SendDlgItemMsg(id_ChgPrnDlgLB1,lb_AddString,word(0),LongInt(pPrinter));
pAllDevicesbuf := pAllDevicesBuf+StrLen(pBuf)+1;
until StrLen(pAllDevicesBuf) = 0;
end;
procedure TChgPrnDlg.IDChgPrtDlgOK(var Msg:TMessage);
var
Idx:Integer;
Buf:Array[0..64] of Char;
Ptr:PChar;
NewDevice:Array[0..64] of Char;
begin
StrCopy(Buf,'');
Ptr := @Buf;
Idx := SendDlgItemMsg(id_ChgPrnDlgLB1,lb_GetCurSel,0,0);
if Idx <> lb_Err then
SendDlgItemMsg(id_ChgPrnDlgLB1,lb_GetText,idx,Longint(Ptr));
if StrLen(Ptr) > 0 then
begin
StrCopy(NewDevice,Buf);
WriteProfileString('Windows','device',NewDevice);
end;
EndDlg(1);
end;
{********************** TLPrinter ************************}
constructor TLPrinter.Init;
begin
TPrinter.Init;
Margin.Left := 0;
Margin.Right := 0;
Margin.Top := 0;
Margin.Bottom := 0;
FooterY := 0;
IsFooter := False;
end;
procedure TLPrinter.PrintLine(aString:PChar);
begin
CurX := Margin.Left;
TextOut(PrintDC,CurX,CurY,aString,StrLen(aString));
CurY := CurY + LineY;
CurX := Margin.Left;
if not IsFooter then
CheckNewPage;
end;
procedure TLPrinter.PrnStop;
begin
if CurY > Margin.Top then
NewPage;
TPrinter.PrnStop;
end;
procedure TLPrinter.CheckNewPage;
begin
if (CurY + Margin.Bottom + 2*LineY + FooterY ) > PageY then
begin
IsFooter := True;
DoFooter;
IsFooter := False;
NewPage;
SetupPage;
end;
end;
procedure TLPrinter.DoHeader;
begin
{formal method}
end;
procedure TLPrinter.DoFooter;
begin
IsFooter := True;
{Include this code when you subclass DoFooter}
IsFooter := False;
end;
procedure TLPrinter.SetupPage;
begin
SetTOP;
DoHeader;
end;
procedure TLPrinter.SetTOP;
begin
CurX := Margin.Left;
CurY := Margin.Top;
end;
procedure TLPrinter.SetMarginL(NewMargin:Integer);
begin
Margin.Left := NewMargin;
end;
procedure TLPrinter.SetMarginR(NewMargin:Integer);
begin
Margin.Right := NewMargin;
end;
procedure TLPrinter.SetMarginT(NewMargin:Integer);
begin
Margin.Top := NewMargin;
end;
procedure TLPrinter.SetMarginB(NewMargin:Integer);
begin
Margin.Bottom := NewMargin;
end;
{***************************************************************}
end.